C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
 
 
 
 
 
 
 
 
C                                   parameter length
 
 
 
 
 
 
 
 
 
C following are for ZYCSDT (Canonicalise Symbol Data Types)
        SUBROUTINE PT(OPTSTR,CMTFD,DESC,NERRS,NWARNS)
        INTEGER OPTSTR(81),CMTFD,DESC,NERRS,NWARNS
 
C ----------------------------------------------------------------------
C
C       I S T P T   -   Toolpack Precision Transformer
C
C       Changes the precision of a Fortran-77 program unit from REAL to
C       DOUBLE PRECISION and vice versa.  Complex arithmetic is not
C       handled and not checked for (COMPLEX variables are noticed, and
C       a warning given if they exist).
C
C       Malcolm Cohen, NAG Central Office, 1984
C
C       Modified: Remove need for all names to be explicitly typed.
C                 Malcolm Cohen, March 1985.
C
C       Modified: Turn the body of the code into a callable subroutine
C                 for "monolithification" of tools.
C                 Malcolm Cohen, July 1985.
C
C       Modified: Add DOUBLE COMPLEX conversions.
C                 Malcolm Cohen, November 1985
C
C       Modified: Add REAL*n and COMPLEX*n handling code.
C                 Malcolm Cohen, December 1985
C
C ----------------------------------------------------------------------
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER ZYDOWN,ZYNEXT,ZYROOT
        EXTERNAL ZYDOWN,ZYNEXT,ZYROOT,ZTOKWR
 
        SAVE
 
        INTEGER PTR,DUMMY(2)
 
        DATA DUMMY(1)/129/
 
        NERROR=NERRS
        NWARN=NWARNS
 
        CALL PTOPT(OPTSTR)
        IF (NERROR.GT.0) THEN
            NERRS=NERROR
            NWARNS=NWARN
            RETURN
        END IF
        PTR=ZYDOWN(ZYROOT())
        PUNUM=0
 
C Initialise i/o descriptors
        IODCMT=CMTFD
        TKDESC=DESC
 
C Canonicalise symbol data types so we can process them
        CALL ZYCSDT(1,.FALSE.)
 
 100    IF (PTR.GT.0) THEN
            PUNUM=PUNUM+1
            CALL PROPU(PTR)
            PTR=ZYNEXT(PTR)
            GO TO 100
        END IF
        CALL ZTOKWR(TZEOF,0,DUMMY,TKDESC)
        NERRS=NERROR
        NWARNS=NWARN
 
        END
C ----------------------------------------------------------------------
C
C       P R O P U   -   Process Program-Unit
C
 
        SUBROUTINE PROPU(PUROOT)
        INTEGER PUROOT
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        INTEGER SPTR,SNUM,BUFF(134),STYPE,PPTR,PTMP,SYMBOL(8)
        LOGICAL SECT1,ESECT1
 
C SECT1: Still in section 1 of a program unit (p.u. header statement,
C        parameter, format, entry and implicit statements)
C ESECT1: Found the end of section 1 (so it is ok to o/p type stmts)
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        INTEGER ZYDOWN,ZYNEXT,ZYGTCM,ZYGNCM,LENGTH,ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZYGTCM,ZYGNCM,LENGTH,YSTMT,ZTOKWR,ZYNTYP,
     +           ZYGTSY,ZYGTST
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        SAVE
 
        DATA SNUM/1/
 
        SPTR=ZYDOWN(PUROOT)
        SECT1=.TRUE.
        ESECT1=.FALSE.
        STYPE=ZYNTYP(SPTR)
        IF (STYPE.EQ.7 .OR. STYPE.EQ.19 .OR.
     +      STYPE.EQ.16 .OR. STYPE.EQ.8) THEN
            PPTR=ZYDOWN(SPTR)
  50        IF (ZYNTYP(PPTR).EQ.108) THEN
                CALL ZYGTSY(-ZYDOWN(PPTR),SYMBOL)
                CALL ZYGTST(SYMBOL(2),BUFF)
                CALL ZITOF(BUFF,1,6,PUNAME,.FALSE.)
            ELSE
                PPTR=ZYNEXT(PPTR)
                IF (PPTR.NE.0) GOTO 50
                PUNAME='$BLOCK'
            END IF
        ELSE
            PUNAME='$MAIN'
        END IF
        PPTR=0
        STMTNO=1
 
 100    IF (ZYGTCM(IODCMT,SNUM,BUFF).EQ.-2) THEN
 200        CALL ZTOKWR(TCMMNT,LENGTH(BUFF),BUFF,TKDESC)
            IF (ZYGNCM(IODCMT,BUFF).EQ.-2) GO TO 200
        END IF
        IF (SECT1) THEN
            STYPE=ZYNTYP(SPTR)
            ESECT1=STYPE.NE.7 .AND. STYPE.NE.8 .AND.
     +             STYPE.NE.16 .AND. STYPE.NE.19 .AND.
     +             STYPE.NE.35 .AND. STYPE.NE.32 .AND.
     +             STYPE.NE.78 .AND. STYPE.NE.18
        END IF
        IF (ESECT1) THEN
            SECT1=.FALSE.
            ESECT1=.FALSE.
            CALL DODECL
            IF (PPTR.NE.0) CALL PTPARA(PPTR,SPTR)
        END IF
        IF (SECT1 .AND. STYPE.EQ.35) THEN
            CALL DOPARA(SPTR,PTMP)
            IF (PTMP.EQ.0) CALL YSTMT(SPTR,TKDESC)
            IF (PPTR.EQ.0) PPTR=PTMP
        ELSE
            CALL DOSTMT(SPTR)
            CALL YSTMT(SPTR,TKDESC)
        END IF
        SNUM=SNUM+1
        STMTNO=STMTNO+1
        SPTR=ZYNEXT(SPTR)
        IF (SPTR.NE.0) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       P T O P T   -   Decode an ISTPT option string.
C
 
        SUBROUTINE PTOPT(OPTSTR)
        INTEGER OPTSTR(81)
 
        COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER OPTTBL(86),STRING(134),POINT,DCFTBL(26),OPTNUM,
     +          LHS(134),RHS(134)
 
        SAVE OPTTBL,DCFTBL,/OPTS/
 
        INTEGER ZKWLUK,GETWRD,ZSPLIT
        EXTERNAL ZKWLUK,GETWRD,ZSPLIT,ZCHOUT,PUTLIN,ZMESS
 
        DATA OPTTBL/8,
     +      97,117,120,105,108,105,97,114,121,95,
     +99,111,110,118,101,114,116,129,
     +      99,111,109,109,111,110,95,99,111,110,118,
     +101,114,116,129,
     +      99,111,110,118,101,114,116,95,110,97,109,
     +101,115,129,
     +      100,99,102,111,114,109,129,
     +      100,111,117,98,108,101,129,
     +      110,97,103,95,114,111,117,116,105,110,101,
     +129,
     +      110,111,110,101,129,
     +      115,105,110,103,108,101,129/
 
        DATA DCFTBL/2,
     +       107,101,121,119,111,114,100,129,
     +       108,101,110,103,116,104,95,115,112,101,99,
     +105,102,105,101,114,129/
 
        CVTNAM=.FALSE.
        CVTAUX=.FALSE.
        CVTCOM=.FALSE.
        RTODBL=.TRUE.
        DTFORM=1
        POINT=1
 
 100    IF (GETWRD(OPTSTR,POINT,STRING).EQ.0) RETURN
        IF (ZSPLIT(STRING,LHS,RHS).NE.-2) THEN
            CALL SCOPY(STRING,1,LHS,1)
            RHS(1)=129
        END IF
        OPTNUM=ZKWLUK(LHS,OPTTBL)
        IF (OPTNUM.LE.0) THEN
            IF (OPTNUM.EQ.0) CALL ZCHOUT('Warning: Ambiguous',2)
            IF (OPTNUM.EQ.-1)  CALL ZCHOUT('Warning: Unknown',2)
            CALL ZCHOUT(' Option "',2)
            CALL PUTLIN(STRING,2)
            CALL ZMESS('" Ignored',2)
        ELSE IF (OPTNUM.EQ.1) THEN
            CVTAUX=.TRUE.
        ELSE IF (OPTNUM.EQ.2) THEN
            CVTCOM=.TRUE.
        ELSE IF (OPTNUM.EQ.3) THEN
            CVTNAM=.TRUE.
        ELSE IF (OPTNUM.EQ.4) THEN
            OPTNUM=ZKWLUK(RHS,DCFTBL)
            IF (OPTNUM.LT.1) THEN
                CALL REMARK('Warning: Invalid value for option DCFORM')
            ELSE IF (OPTNUM.EQ.1) THEN
                DTFORM=1
            ELSE
                DTFORM=3
            END IF
        ELSE IF (OPTNUM.EQ.5) THEN
            RTODBL=.TRUE.
        ELSE IF (OPTNUM.EQ.6) THEN
            CVTNAM=.TRUE.
            CVTAUX=.TRUE.
            CVTCOM=.TRUE.
        ELSE IF (OPTNUM.EQ.8) THEN
            RTODBL=.FALSE.
        END IF
        GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       D O P A R A   -   Scan PARAMETER statement for implicitly typed
C                         names which have changed type
C
 
        SUBROUTINE DOPARA(SPTR,PPTR)
        INTEGER SPTR,PPTR
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER PTR,SYMBOL(8),DUMMY(2)
        LOGICAL FIRST
 
        SAVE /OPTS/,/PTIO/
 
        INTEGER ZYDOWN,ZYNEXT,ZIAND
        EXTERNAL ZYDOWN,ZYNEXT,ZIAND,ZYGTSY,ZTOKWR,YLEAF,YEXPR
 
        DATA DUMMY(1)/129/
 
        PPTR=0
        PTR=ZYDOWN(SPTR)
 100    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
        IF ((RTODBL .AND.
     +          (SYMBOL(4).EQ.2 .OR.
     +           SYMBOL(4).EQ.4) .OR.
     +      .NOT.RTODBL .AND.
     +          (SYMBOL(4).EQ.5 .OR.
     +           SYMBOL(4).EQ.7)) .AND.
     +      ZIAND(SYMBOL(6),
     +            8+4096+2).EQ.0) THEN
            PPTR=SPTR
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 100
        IF (PPTR.NE.SPTR) RETURN
 
C Found a nasty-type PARAMETER statement - output anything from it that
C we must
 
        PTR=ZYDOWN(SPTR)
        FIRST=.TRUE.
 200    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
        IF (.NOT.(
     +          (RTODBL .AND.
     +              (SYMBOL(4).EQ.2 .OR.
     +               SYMBOL(4).EQ.4) .OR.
     +          .NOT.RTODBL .AND.
     +              (SYMBOL(4).EQ.5 .OR.
     +               SYMBOL(4).EQ.7)) .AND.
     +          ZIAND(SYMBOL(6),
     +              8+4096+2).EQ.0)) THEN
            IF (FIRST) THEN
                CALL ZTOKWR(TPARAM,0,DUMMY,TKDESC)
                CALL ZTOKWR(TLPARN,0,DUMMY,TKDESC)
                FIRST=.FALSE.
            ELSE
                CALL ZTOKWR(TCOMMA,0,DUMMY,TKDESC)
            END IF
            CALL YLEAF(ZYDOWN(PTR),TKDESC)
            CALL ZTOKWR(TEQUAL,0,DUMMY,TKDESC)
            CALL YEXPR(ZYNEXT(ZYDOWN(PTR)),TKDESC)
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 200
        IF (.NOT.FIRST) THEN
            CALL ZTOKWR(TRPARN,0,DUMMY,TKDESC)
            CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       P T P A R A   -   Put extra PARAMETER statements out now, after
C                         the appropriate type statements
C
 
        SUBROUTINE PTPARA(PPTR,FPTR)
        INTEGER PPTR,FPTR
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER PTR,SYMBOL(8),SPTR,DUMMY(2)
 
        SAVE /OPTS/,/PTIO/
 
        INTEGER ZYDOWN,ZYNEXT,ZIAND,ZYNTYP
        EXTERNAL ZYDOWN,ZYNEXT,ZIAND,ZYNTYP,ZYGTSY,ZTOKWR,YLEAF,YEXPR
 
        DATA DUMMY(1)/129/
 
        SPTR=PPTR
 100    PTR=ZYDOWN(SPTR)
        CALL DOSTMT(SPTR)
 200    CALL ZYGTSY(-ZYDOWN(ZYDOWN(PTR)),SYMBOL)
        IF ((RTODBL .AND.
     +          (SYMBOL(4).EQ.2 .OR.
     +           SYMBOL(4).EQ.4) .OR.
     +      .NOT.RTODBL .AND.
     +          (SYMBOL(4).EQ.5 .OR.
     +           SYMBOL(4).EQ.7)) .AND.
     +      ZIAND(SYMBOL(6),
     +            8+4096+2).EQ.0) THEN
            CALL ZTOKWR(TPARAM,0,DUMMY,TKDESC)
            CALL ZTOKWR(TLPARN,0,DUMMY,TKDESC)
            CALL YLEAF(ZYDOWN(PTR),TKDESC)
            CALL ZTOKWR(TEQUAL,0,DUMMY,TKDESC)
            CALL YEXPR(ZYNEXT(ZYDOWN(PTR)),TKDESC)
            CALL ZTOKWR(TRPARN,0,DUMMY,TKDESC)
            CALL ZTOKWR(TZEOS,0,DUMMY,TKDESC)
        END IF
        PTR=ZYNEXT(PTR)
        IF (PTR.NE.0) GOTO 200
 300    SPTR=ZYNEXT(SPTR)
        IF (SPTR.NE.FPTR) THEN
            IF (ZYNTYP(SPTR).EQ.35) GOTO 100
            GOTO 300
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       D O D E C L   -   Do declare implicitly typed names
C
 
        SUBROUTINE DODECL
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        SAVE /PTERRC/,/OPTS/,/PTIO/
 
        INTEGER SYMPTR,SYMBOL(8),TEXT(134),TEXT2(134)
 
        LOGICAL NAMCH1
 
        INTEGER ZYGNSW,ZIAND,LENGTH
        EXTERNAL ZYGNSW,ZIAND,YDTYPE,ZYGTST,LENGTH,SCOPY
 
        SYMPTR=0
        IF (ZYGNSW(SYMPTR,PUNUM,SYMBOL).NE.-2)
     +      CALL ERROR('No symbols in program unit')
 100    IF ((RTODBL .AND.
     +          (SYMBOL(4).EQ.2 .OR.
     +           SYMBOL(4).EQ.4) .OR.
     +      .NOT.RTODBL .AND.
     +          (SYMBOL(4).EQ.5 .OR.
     +           SYMBOL(4).EQ.7)) .AND.
     +      ZIAND(SYMBOL(6),
     +            8+4096+2).EQ.0) THEN
            CALL ZYGTST(SYMBOL(2),TEXT)
            IF (CVTNAM .OR. CVTAUX) THEN
                IF (NAMCH1(TEXT,TEXT2)) CALL SCOPY(TEXT2,1,TEXT,1)
            END IF
            IF (SYMBOL(4).EQ.2 .AND.
     +          SYMBOL(5).EQ.0) THEN
                CALL YDTYPE(5,0,TKDESC)
            ELSE IF (SYMBOL(4).EQ.2) THEN
                CALL YDTYPE(2,SYMBOL(5),TKDESC)
            ELSE IF (SYMBOL(4).EQ.4) THEN
                IF (DTFORM.EQ.1) THEN
                    CALL YDTYPE(7,0,TKDESC)
                ELSE
                    CALL YDTYPE(4,4*4,TKDESC)
                END IF
            ELSE IF (SYMBOL(4).EQ.5) THEN
                CALL YDTYPE(2,0,TKDESC)
            ELSE
                CALL YDTYPE(4,0,TKDESC)
            END IF
            CALL ZTOKWR(TNAME,LENGTH(TEXT),TEXT,TKDESC)
            TEXT(1)=129
            CALL ZTOKWR(TZEOS,0,TEXT,TKDESC)
        END IF
        IF (ZYGNSW(SYMPTR,PUNUM,SYMBOL).EQ.-2) GOTO 100
 
        END
C ----------------------------------------------------------------------
C
C       D O S T M T   -   Process statement
C
 
        SUBROUTINE DOSTMT(SROOT)
        INTEGER SROOT
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER PTR,STYPE,NTYPE,DFR(6),DFP(27),RFR(6),RFP(27),STATUS,
     +          STR1(134),STR2(134),STRPTR,NEXT,PTR2,VALUE
 
        SAVE /OPTS/,DFP,RFP,DFR,RFR
 
        INTEGER ZYNTYP,ZYNEXT,ZYDOWN,ZSETP,ZSETR,ZPREPL,ADDSTR,ZYUP,
     +          CTOI,ITOC,ZYASTR,ZYCRND
        EXTERNAL ZYNTYP,ZYNEXT,ZYDOWN,ZSETP,ZSETR,ZPREPL,ZYGTST,ADDSTR,
     +           ZYSATT,ZYUP,ZYCHNT,ZYDELT,CTOI,ITOC,SKIPBL,ZYASTR,
     +           ZYCRND,ZYADSN
 
C RFP "%<[0-9]*>E<[0-9]*.[0-9]*>$"
C DFP "%<[0-9]*>D<[0-9]*.[0-9]*>$"
C RFR "&1E&2"
C DFR "&1D&2"
 
        DATA RFP/37,60,91,48,45,57,93,42,62,
     +69,60,91,48,45,57,93,42,46,91,48,
     +45,57,93,42,62,36,129/
        DATA DFP/37,60,91,48,45,57,93,42,62,
     +68,60,91,48,45,57,93,42,46,91,48,
     +45,57,93,42,62,36,129/
        DATA RFR/38,49,69,38,50,129/
        DATA DFR/38,49,68,38,50,129/
 
        STYPE=ZYNTYP(SROOT)
        PTR=ZYDOWN(SROOT)
        IF (STYPE.EQ.78) THEN
C FORMAT
            IF (RTODBL) THEN
                STATUS=ZSETP(RFP,.TRUE.)
                STATUS=ZSETR(DFR)
            ELSE
                STATUS=ZSETP(DFP,.TRUE.)
                STATUS=ZSETR(RFR)
            END IF
 100        IF (ZYNTYP(PTR).EQ.112) THEN
                CALL ZYGTST(-ZYDOWN(PTR),STR1)
                IF (ZPREPL(STR1,STR2,.FALSE.).EQ.-2) THEN
                    STRPTR=ADDSTR(STR2)
                    CALL ZYCHDN(PTR,-STRPTR)
                END IF
            END IF
            NEXT=ZYDOWN(PTR)
 200        IF (NEXT.LE.0) NEXT=ZYNEXT(PTR)
            IF (NEXT.LE.0) THEN
                PTR=ZYUP(PTR)
                IF (PTR.NE.SROOT) GO TO 200
            END IF
            IF (NEXT.GT.0) THEN
                PTR=NEXT
                GO TO 100
            END IF
        ELSE IF (STYPE.EQ.24) THEN
C EQUIVALENCE
            CALL CHKEQV(PTR)
        ELSE IF (STYPE.NE.20 .AND.
     +      (STYPE.NE.26 .OR. CVTCOM)) THEN
C All other appropriate statements
            IF (STYPE.EQ.8 .OR. STYPE.EQ.30) THEN
C FUNCTION/TYPE only
                IF (ZYNTYP(PTR).EQ.115) PTR=ZYNEXT(PTR)
                NTYPE=ZYNTYP(PTR)
                IF (NTYPE.EQ.10) THEN
                    PTR2=ZYDOWN(PTR)
                    IF (PTR2.NE.0) THEN
C Handle REAL*n cases by converting them to their equivalents
                        CALL ZYGTST(-ZYDOWN(PTR2),STR1)
                        PTR2=1
                        VALUE=CTOI(STR1,PTR2)
                        IF (VALUE.EQ.4*4) THEN
                            CALL OUTERR(
     +                          'Cannot handle quadruple precision')
                        ELSE IF (VALUE.EQ.2*4) THEN
                            CALL ZYCHNT(PTR,11)
                            NTYPE=11
                        ELSE IF (VALUE.NE.4) THEN
                            CALL  OUTERR('Invalid REAL*value')
                        END IF
                        IF (VALUE.EQ.4 .OR.
     +                      VALUE.EQ.2*4)
     +                      CALL ZYDELT(ZYDOWN(PTR))
                    END IF
                ELSE IF (NTYPE.EQ.12) THEN
                    PTR2=ZYDOWN(PTR)
                    IF (PTR2.NE.0) THEN
C Ditto COMPLEX*n
                        CALL ZYGTST(-ZYDOWN(PTR2),STR1)
                        PTR2=1
                        VALUE=CTOI(STR1,PTR2)
                        IF (VALUE.EQ.4*4) THEN
                            CALL ZYCHNT(PTR,125)
                            NTYPE=125
                        ELSE IF (VALUE.NE.2*4) THEN
                            CALL OUTERR('Invalid COMPLEX*value')
                        END IF
                        IF (VALUE.EQ.2*4 .OR.
     +                      VALUE.EQ.4*4)
     +                      CALL ZYDELT(ZYDOWN(PTR))
                    END IF
                END IF
                IF (NTYPE.EQ.10 .AND. ZYDOWN(PTR).EQ.0) THEN
                    IF (RTODBL) THEN
                        CALL ZYCHNT(PTR,11)
                    ELSE
                        CALL OUTWRN('Already single-precision')
                    END IF
                ELSE IF (NTYPE.EQ.11) THEN
                    IF (RTODBL) THEN
                        CALL OUTWRN('Already double-precision')
                    ELSE
                        CALL ZYCHNT(PTR,10)
                    END IF
                ELSE IF (NTYPE.EQ.12) THEN
                    IF (RTODBL) THEN
                        IF (DTFORM.EQ.1) THEN
                            CALL ZYCHNT(PTR,125)
                        ELSE
                            PTR2=ITOC(4*4,STR1,3)
                            PTR2=1
                            CALL SKIPBL(STR1,PTR2)
                            CALL ZYADSN(PTR,ZYCRND(107,
     +                                             -ADDSTR(STR1(PTR2))))
                        END IF
                    ELSE
                        CALL OUTWRN('Already single-precision complex')
                    END IF
                ELSE IF (NTYPE.EQ.125) THEN
                    IF (RTODBL) THEN
                        CALL OUTWRN('Already double-precision complex')
                        IF (DTFORM.NE.1) THEN
                            CALL ZYCHNT(PTR,12)
                            PTR2=ITOC(4*4,STR1,3)
                            PTR2=1
                            CALL SKIPBL(STR1,PTR2)
                            CALL ZYADSN(PTR,ZYCRND(107,
     +                                             -ADDSTR(STR1(PTR2))))
                        END IF
                    ELSE
                        CALL ZYCHNT(PTR,12)
                    END IF
                END IF
            END IF
C All including FUNCTION/TYPE (but not FORMAT/EQUIVALENCE/etc.
            IF (PTR.EQ.0) RETURN
 300        NTYPE=ZYNTYP(PTR)
            IF (NTYPE.EQ.110 .OR. NTYPE.EQ.111 .OR.
     +          NTYPE.EQ.102) THEN
                CALL CHCNST(PTR,NTYPE)
            ELSE IF (NTYPE.EQ.108) THEN
                CALL CHNAME(PTR)
            ELSE IF (NTYPE.EQ.40 .AND. CVTCOM) THEN
                CALL CHCNAM(PTR)
            END IF
            NEXT=ZYDOWN(PTR)
 400        IF (NEXT.LE.0) NEXT=ZYNEXT(PTR)
            IF (NEXT.LE.0) THEN
                PTR=ZYUP(PTR)
                IF (PTR.NE.SROOT) GO TO 400
            END IF
            IF (NEXT.GT.0) THEN
                PTR=NEXT
                GO TO 300
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C H K E Q V   -   Check EQUIVALENCE statement for badness
C
 
        SUBROUTINE CHKEQV(NODE)
        INTEGER NODE
 
        COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER SETPTR,ELTPTR,NXITMS,NOITMS,SYMBOL(8),PTR
 
        INTEGER ZYNTYP,ZYDOWN,ZYNEXT
        EXTERNAL ZYNTYP,ZYDOWN,ZYNEXT,ZYGTSY
 
        SAVE /OPTS/
 
        SETPTR=NODE
 
 100    ELTPTR=ZYDOWN(SETPTR)
        NXITMS=0
        NOITMS=0
 
 200    IF (ZYNTYP(ELTPTR).EQ.108) THEN
            CALL ZYGTSY(-ZYDOWN(ELTPTR),SYMBOL)
        ELSE
            PTR=ZYDOWN(ELTPTR)
            IF (ZYNTYP(PTR).NE.108) PTR=ZYDOWN(PTR)
            CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
        END IF
        IF (((SYMBOL(4).EQ.2 .OR.
     +      SYMBOL(4).EQ.4).AND. RTODBL) .OR.
     +      ((SYMBOL(4).EQ.5 .OR.
     +      SYMBOL(4).EQ.7) .AND. .NOT.RTODBL)) THEN
            NXITMS=NXITMS+1
        ELSE
            NOITMS=NOITMS+1
        END IF
        ELTPTR=ZYNEXT(ELTPTR)
        IF (ELTPTR.GT.0) GO TO 200
        IF (NXITMS.GT.0 .AND. NOITMS.GT.0) THEN
            CALL OUTERR('EQUIVALENCE statement has changed meaning')
        ELSE
            SETPTR=ZYNEXT(SETPTR)
            IF (SETPTR.GT.0) GO TO 100
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C H C N S T   -   Change constant
C
 
        SUBROUTINE CHCNST(PTR,NTYPE)
        INTEGER PTR,NTYPE
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER STRPTR,STR1(134),STR2(134),STATUS,RR1(3),RR2(6),
     +          DR1(6),DR2(5),RCP1(35),RCP2(19),DCP1(20),DCP2(35),P1,P2,
     +          I
 
        SAVE RR1,DR1,RR2,DR2,RCP1,RCP2,DCP1,DCP2,/OPTS/
 
        INTEGER ADDSTR,ZPREPL,ZSETR,ZSETP,ZYDOWN,ZYNTYP,ZYNEXT,LENGTH
        EXTERNAL ZYGTST,ADDSTR,ZYCHDN,ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYNTYP,
     +           ZYNEXT,LENGTH
 
C RCP1 "%<[0-9]*.*[0-9]*>E<[+@- ]*[0-9]*>$"
C RCP2 "%<[0-9]*.*[0-9]*>$"
C DCP1 "%<[0-9]*.[0-9]*>D0$"
C DCP2 "%<[0-9]*.*[0-9]*>D<[+@- ]*[0-9]*>$"
C RR1 "&1"
C DR1 "&1D&2"
C RR2 "&1E&2"
C DR2 "&1D0"
 
        DATA RCP1/37,60,91,48,45,57,93,42,
     +46,42,91,48,45,57,93,42,62,69,60,
     +91,64,43,45,32,93,42,91,48,45,57,
     +93,42,62,36,129/
        DATA RCP2/37,60,91,48,45,57,93,42,
     +46,42,91,48,45,57,93,42,62,36,129/
        DATA DCP1/37,60,91,48,45,57,93,42,
     +46,91,48,45,57,93,42,62,68,48,
     +36,129/
        DATA DCP2/37,60,91,48,45,57,93,42,
     +46,42,91,48,45,57,93,42,62,68,60,
     +91,43,64,45,32,93,42,91,48,45,57,
     +93,42,62,36,129/
        DATA RR2/38,49,69,38,50,129/
        DATA DR1/38,49,68,38,50,129/
        DATA RR1/38,49,129/
        DATA DR2/38,49,68,48,129/
 
        IF (NTYPE.NE.102) CALL ZYGTST(-ZYDOWN(PTR),STR1)
        IF (NTYPE.EQ.110) THEN
            IF (RTODBL) THEN
                STATUS=ZSETP(RCP1,.TRUE.)
                STATUS=ZSETR(DR1)
                STATUS=ZPREPL(STR1,STR2,.FALSE.)
                IF (STATUS.NE.-2) THEN
                    STATUS=ZSETP(RCP2,.TRUE.)
                    STATUS=ZSETR(DR2)
                    STATUS=ZPREPL(STR1,STR2,.FALSE.)
                END IF
                IF (STATUS.NE.-2) THEN
                    CALL OUTERR('Invalid real constant format')
                ELSE
                    STRPTR=ADDSTR(STR2)
                    CALL ZYCHDN(PTR,-STRPTR)
                    CALL ZYCHNT(PTR,111)
                END IF
            ELSE
                CALL OUTWRN('Constant already single-precision')
            END IF
 
        ELSE IF (NTYPE.EQ.111) THEN
            IF (RTODBL) THEN
                CALL OUTWRN('Constant already double-precision')
            ELSE
                STATUS=ZSETP(DCP1,.TRUE.)
                STATUS=ZSETR(RR1)
                STATUS=ZPREPL(STR1,STR2,.FALSE.)
                IF (STATUS.NE.-2) THEN
                    STATUS=ZSETP(DCP2,.TRUE.)
                    STATUS=ZSETR(RR2)
                    STATUS=ZPREPL(STR1,STR2,.FALSE.)
                END IF
                IF (STATUS.NE.-2) THEN
                    CALL OUTERR('Invalid double precision constant')
                ELSE
                    STRPTR=ADDSTR(STR2)
                    CALL ZYCHDN(PTR,-STRPTR)
                    CALL ZYCHNT(PTR,110)
                END IF
            END IF
        ELSE IF (NTYPE.EQ.102) THEN
            P1=ZYDOWN(PTR)
            P2=ZYNEXT(P1)
            IF (ZYNTYP(P1).EQ.46) P1=ZYDOWN(P1)
            IF (ZYNTYP(P2).EQ.46) P2=ZYDOWN(P2)
            IF (ZYNTYP(P1).EQ.107 .AND. ZYNTYP(P2).EQ.107)
     +      THEN
C Complex constant with both parts integral - change first to real so
C it will be converted to the correct type of constant later.
                CALL ZYGTST(-ZYDOWN(P1),STR1)
                I=LENGTH(STR1)+1
                STR1(I)=69
                STR1(I+1)=48
                STR1(I+2)=129
                STRPTR=ADDSTR(STR1)
                CALL ZYCHDN(P1,-STRPTR)
                CALL ZYCHNT(P1,110)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C H N A M E   -   Change name if necessary
C
 
        SUBROUTINE CHNAME(PTR)
        INTEGER PTR
 
        INTEGER NRTODF,NDTORF,NBADF
        PARAMETER (NRTODF=9,NDTORF=19,NBADF=11)
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        INTEGER SYMBOL(8),TEXT1(134),TEXT2(134),
     +          STRPTR,I,SYMPTR,NTYPE
        LOGICAL CHG
        CHARACTER*6 FNAME,RTODFN(2,NRTODF),DTORFN(2,NDTORF),
     +              BADFNS(NBADF)
 
        SAVE /OPTS/,RTODFN,DTORFN,BADFNS,/PTERRC/
 
        LOGICAL BADFUN,NAMCH1
        INTEGER ZYDOWN,ZIAND,ZYNTYP,ZYUP,ADDSTR,ZYASYM
        EXTERNAL ZYDOWN,ZIAND,ZYGTSY,ZYGTST,ZITOF,ZYASYM,ZYCHDN,
     +           ZFTOI,ZYNTYP,ZYUP,ZSTRIP,ADDSTR
 
        DATA RTODFN/'AMOD','DMOD','AMAX1','DMAX1','AMIN1','DMIN1',
     +'ALOG','DLOG','ALOG10','DLOG10','AIMAG','DIMAG',
     +'CMPLX','DCMPLX','CONJG','DCONJG','CABS','CDABS'/,
     +       DTORFN/'DINT','AINT','DNINT','ANINT','IDNINT','NINT',
     +'DABS','ABS','DSIGN','SIGN','DDIM','DIM','DSQRT','SQRT',
     +'DEXP','EXP','DSIN','SIN','DCOS','COS','DTAN','TAN',
     +'DASIN','ASIN','DACOS','ACOS','DATAN','ATAN','DATAN2','ATAN2',
     +'DSINH','SINH','DCOSH','COSH','DTANH','TANH','IDINT','INT'/,
     +       BADFNS/'INT','SNGL','DBLE','DPROD','MAX1','AMAX0',
     +'AMIN0','MIN1','REAL','FLOAT','IFIX'/
 
C RTODFN: Functions which must always be changed from one to the other
C         (we do not attempt to genericise the program at all).
C DTORFN: Functions which must always be changed from double precision,
C         but whose single-precision forms are generic names, so need only
C         be changed when used as an actual parameter.
C BADFNS: Functions which need special checking or special processing, such
C         as type conversion functions involving real or double.
 
        CALL ZYGTSY(-ZYDOWN(PTR),SYMBOL)
        IF (SYMBOL(1).NE.7 .AND.
     +      SYMBOL(1).NE.4) RETURN
        CALL ZYGTST(SYMBOL(2),TEXT1)
        IF (ZIAND(SYMBOL(6),4096).EQ.0) THEN
            IF (NAMCH1(TEXT1,TEXT2)) THEN
                STRPTR=ADDSTR(TEXT2)
                SYMPTR=ZYASYM(STRPTR,PUNUM,SYMBOL(1))
                CALL ZYCHDN(PTR,-SYMPTR)
            END IF
        ELSE
            CHG=.FALSE.
            CALL ZITOF(TEXT1,1,6,FNAME,.FALSE.)
            IF (RTODBL) THEN
                I=0
 100            I=I+1
                IF (I.LT.NRTODF .AND. RTODFN(1,I).NE.FNAME) GOTO 100
                NTYPE=ZYNTYP(ZYUP(PTR))
                IF (RTODFN(1,I).EQ.FNAME) THEN
                    FNAME=RTODFN(2,I)
                    CHG=.TRUE.
                ELSE IF (NTYPE.NE.119 .AND.
     +                   NTYPE.NE.38) THEN
                    I=0
 200                I=I+1
                    IF (I.LT.NDTORF .AND. DTORFN(2,I).NE.FNAME) GOTO 200
                    IF (DTORFN(2,I).EQ.FNAME) THEN
                        FNAME=DTORFN(1,I)
                        CHG=.TRUE.
                    END IF
                END IF
            ELSE
                I=0
 300            I=I+1
                IF (I.LT.NDTORF .AND. DTORFN(1,I).NE.FNAME) GOTO 300
                IF (DTORFN(1,I).EQ.FNAME) THEN
                    FNAME=DTORFN(2,I)
                    CHG=.TRUE.
                ELSE
                    I=0
 400                I=I+1
                    IF (I.LT.NRTODF .AND. RTODFN(2,I).NE.FNAME) GOTO 400
                    IF (RTODFN(2,I).EQ.FNAME) THEN
                        FNAME=RTODFN(1,I)
                        CHG=.TRUE.
                    END IF
                END IF
            END IF
            IF (.NOT.CHG) THEN
                I=0
 500            I=I+1
                IF (I.LT.NBADF .AND. BADFNS(I).NE.FNAME) GOTO 500
                IF (BADFNS(I).EQ.FNAME) CHG=BADFUN(PTR,FNAME,I)
            END IF
            IF (CHG) THEN
                CALL ZFTOI(FNAME,1,6,TEXT2,.FALSE.)
                CALL ZSTRIP(TEXT2)
                STRPTR=ADDSTR(TEXT2)
                SYMPTR=ZYASYM(STRPTR,PUNUM,7)
                CALL ZYCHDN(PTR,-SYMPTR)
            END IF
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       N A M C H 1   -   Change name type 1: ordinary (not intrinsic)
C
 
        LOGICAL FUNCTION NAMCH1(TEXT1,TEXT2)
        INTEGER TEXT1(*),TEXT2(*)
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER DP(31),RP(31),DR(4),RR(4),RAP(38),DAP(38),AR(5),STATUS
 
        SAVE /OPTS/,DP,RP,DR,RR,RAP,DAP,AR
 
        INTEGER ZSETR,ZSETP,ZPREPL
        EXTERNAL ZSETR,ZSETP,ZPREPL
 
C DP: "%<[A-Z][0-9][0-9][A-Z][A-Z]>D$"  [Nag routine name, double]
C RP: "%<[A-Z][0-9][0-9][A-Z][A-Z]>F$"  [Nag routine name, single]
C DR: "&1D" [Change to double]
C RR: "&1F" [Change to single]
C RAP: "%<[A-Z][0-9][0-9]><[A-Z][A-Z][BG-Z]>$" [Nag aux name, single]
C DAP: "%<[A-Z][A-Z][BG-Z]><[A-Z][0-9][0-9]>$" [Nag aux name, double]
C AR: "&2&1" [Change between aux single/double, either way]
 
        DATA DP/37,60,91,65,45,90,93,91,48,
     +45,57,93,91,48,45,57,93,91,65,45,
     +90,93,91,65,45,90,93,62,68,36,129/
        DATA RP/37,60,91,65,45,90,93,91,48,
     +45,57,93,91,48,45,57,93,91,65,45,
     +90,93,91,65,45,90,93,62,70,36,129/
        DATA DR/38,49,68,129/
        DATA RR/38,49,70,129/
        DATA RAP/37,60,91,65,45,90,93,91,48,
     +45,57,93,91,48,45,57,93,62,60,91,
     +65,45,90,93,91,65,45,90,93,91,66,
     +71,45,90,93,62,36,129/
        DATA DAP/37,60,91,65,45,90,93,91,65,
     +45,90,93,91,66,71,45,90,93,62,60,
     +91,65,45,90,93,91,48,45,57,93,91,
     +48,45,57,93,62,36,129/
        DATA AR/38,50,38,49,129/
 
        NAMCH1=.FALSE.
        IF (CVTNAM) THEN
            IF (RTODBL) THEN
                STATUS=ZSETP(RP,.TRUE.)
                STATUS=ZSETR(DR)
            ELSE
                STATUS=ZSETP(DP,.TRUE.)
                STATUS=ZSETR(RR)
            END IF
            NAMCH1=ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2
        END IF
        IF (CVTAUX .AND. .NOT.NAMCH1) THEN
            IF (RTODBL) THEN
                STATUS=ZSETP(RAP,.TRUE.)
            ELSE
                STATUS=ZSETP(DAP,.TRUE.)
            END IF
            STATUS=ZSETR(AR)
            NAMCH1=ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       B A D F U N   -   Handle bad intrinsic functions
C                         (result = change function name?)
C
 
        LOGICAL FUNCTION BADFUN(PTR,FNAME,INDX)
        INTEGER PTR,INDX
        CHARACTER*6 FNAME
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/OPTS/ CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
        INTEGER NTYPE,TMP,SYMBOL(8),TEXT(134),
     +          REALTX(5),DBLETX(5),INTTXT(4)
        LOGICAL TEST
 
        SAVE /OPTS/,REALTX,DBLETX,INTTXT,/PTERRC/
 
        INTEGER ZYUP,ZYNTYP,ZYDOWN,ZYNEXT,EQUAL,ZIAND,ZYPREV,ADDSTR,
     +          ZYASYM,ZYCRND
        EXTERNAL ZYUP,ZYNTYP,ZYDOWN,ZYNEXT,ZYREPL,ZYCHNT,ZYDELT,ZYGTSY,
     +           ZYGTST,EQUAL,ZTOCAP,ZIAND,ZYPREV,ADDSTR,ZYASYM,ZYCRND
 
        DATA REALTX/82,69,65,76,129/,
     +       DBLETX/68,66,76,69,129/,
     +       INTTXT/73,78,84,129/
 
        NTYPE=ZYNTYP(ZYUP(PTR))
        BADFUN=.FALSE.
        GOTO (1000,2000,3000,4000,5000,6000,7000,8000,9000,10000,11000)
     +       INDX
        CALL ERROR('INTERNAL ERROR - PROGRAM ABORTED')
 
C INT
 1000   CONTINUE
        IF (NTYPE.NE.119 .AND. NTYPE.NE.38) THEN
            IF (RTODBL) THEN
                FNAME='IDINT'
                BADFUN=.TRUE.
            ELSE
                CALL OUTWRN('Already single-precision (INT)')
            END IF
        END IF
        RETURN
 
C SNGL
 2000   CONTINUE
        IF (.NOT.RTODBL) THEN
            CALL OUTWRN('Already single-precision (SNGL)')
            IF (NTYPE.EQ.119)
     +          CALL OUTERR('Probably incorrect code (SNGL)')
        ELSE IF (NTYPE.EQ.119) THEN
            TMP=ZYNEXT(PTR)
            CALL ZYREPL(ZYUP(PTR),TMP)
            PTR=ZYPREV(TMP)
            IF (ZYNEXT(PTR).EQ.0) PTR=ZYUP(TMP)
            CALL OUTWRN('Non-reversible tranformation (SNGL)')
        ELSE IF (NTYPE.EQ.38) THEN
            IF (ZYNEXT(PTR).NE.0) THEN
                PTR=ZYPREV(PTR)
                CALL ZYREPL(ZYNEXT(PTR),ZYNEXT(ZYNEXT(PTR)))
            ELSE
                CALL OUTINF('Probably unnecessary SNGL declaration')
            END IF
        ELSE
            CALL OUTERR('Couldn''t transform SNGL usage')
        END IF
        RETURN
 
C DBLE
 3000   CONTINUE
        IF (RTODBL) THEN
            CALL OUTWRN('Already double-precision (DBLE)')
        ELSE
            FNAME='REAL'
            BADFUN=.TRUE.
        END IF
        RETURN
 
C DPROD
 4000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                CALL OUTWRN('DPROD found - result may be incorrect')
                PTR=ZYUP(PTR)
                CALL ZYCHNT(PTR,98)
                CALL ZYDELT(ZYDOWN(PTR))
C Now put brackets around the arguments if necessary
                TMP=ZYDOWN(PTR)
                NTYPE=ZYNTYP(TMP)
                IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
     +              NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
                    CALL ZYDELT(TMP)
                    TMP=ZYCRND(101,TMP)
                    CALL ZYADNX(TMP,ZYDOWN(PTR))
C Reverse the reversed arguments
                    CALL ZYADNX(ZYDOWN(PTR),ZYNEXT(ZYDOWN(PTR)))
                END IF
                TMP=ZYNEXT(ZYDOWN(PTR))
                NTYPE=ZYNTYP(TMP)
                IF (NTYPE.EQ.95 .OR. NTYPE.EQ.96 .OR.
     +              NTYPE.EQ.98 .OR. NTYPE.EQ.99 .OR.
     +              NTYPE.EQ.97 .OR. NTYPE.EQ.46) THEN
                    CALL ZYDELT(TMP)
                    TMP=ZYCRND(101,TMP)
                    CALL ZYADNX(TMP,ZYDOWN(PTR))
                END IF
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Probably unnecessary DPROD decl')
                END IF
            ELSE
                CALL OUTERR('Couldn''t transform DPROD usage')
            END IF
        ELSE
            CALL OUTERR('DP Code uses DPROD - too complicated')
        END IF
        RETURN
 
C MAX1
 5000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
     +                  ADDSTR(INTTXT),PUNUM,7)))
                CALL ZYREPL(ZYUP(PTR),TMP)
                CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
                FNAME='MAX'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Probably unneeded MAX1 declaration')
                END IF
            ELSE
                CALL OUTERR('Couldn''t transform MAX1 usage')
            END IF
        ELSE
            CALL OUTERR('DP code uses MAX1 - too complicated')
        END IF
        RETURN
 
C AMAX0
 6000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
     +                  ADDSTR(DBLETX),PUNUM,7)))
                CALL ZYREPL(ZYUP(PTR),TMP)
                CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
                FNAME='MAX'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Probably unneeded AMAX0 declaration')
                END IF
            ELSE
                CALL OUTERR('Couldn''t transform AMAX0 usage')
            END IF
        ELSE
            TMP=ZYUP(ZYUP(PTR))
            IF (NTYPE.EQ.119 .AND. ZYNTYP(TMP).EQ.119) THEN
C Must check for REAL(AMAX0 generated from DBLE(AMAX0
                CALL ZYGTSY(-ZYDOWN(ZYDOWN(TMP)),SYMBOL)
                CALL ZYGTST(SYMBOL(2),TEXT)
                CALL ZTOCAP(TEXT)
                TEST=EQUAL(TEXT,REALTX).EQ.-2
            ELSE
                TEST=.FALSE.
            END IF
            IF (TEST) THEN
                CALL ZYREPL(TMP,ZYUP(PTR))
            ELSE
                CALL OUTERR('Couldn''t transform AMAX0 usage')
            END IF
        END IF
        RETURN
 
C AMIN0
 7000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
     +                  ADDSTR(DBLETX),PUNUM,7)))
                CALL ZYREPL(ZYUP(PTR),TMP)
                CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
                FNAME='MIN'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Probably unneeded AMIN0 declaration')
                END IF
            ELSE
                CALL OUTERR('Couldn''t transform AMIN0 usage')
            END IF
        ELSE
            TMP=ZYUP(ZYUP(PTR))
            IF (NTYPE.EQ.119 .AND. ZYNTYP(TMP).EQ.119) THEN
C Must check for REAL(AMIN0 generated from DBLE(AMIN0
                CALL ZYGTSY(-ZYDOWN(ZYDOWN(TMP)),SYMBOL)
                CALL ZYGTST(SYMBOL(2),TEXT)
                CALL ZTOCAP(TEXT)
                TEST=EQUAL(TEXT,REALTX).EQ.-2
            ELSE
                TEST=.FALSE.
            END IF
            IF (TEST) THEN
                CALL ZYREPL(TMP,ZYUP(PTR))
            ELSE
                CALL OUTERR('Couldn''t transform AMIN0 usage')
            END IF
        END IF
        RETURN
 
C MIN1
 8000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                TMP=ZYCRND(119,ZYCRND(108,-ZYASYM(
     +                  ADDSTR(INTTXT),PUNUM,7)))
                CALL ZYREPL(ZYUP(PTR),TMP)
                CALL ZYADNX(ZYUP(PTR),ZYDOWN(TMP))
                FNAME='MIN'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Probably unneeded MIN1 declaration')
                END IF
            ELSE
                CALL OUTERR('Couldn''t transform MIN1 usage')
            END IF
        ELSE
            CALL OUTERR('DP code uses MIN1 - too complicated')
        END IF
        RETURN
 
C REAL
 9000   CONTINUE
        IF (RTODBL) THEN
            FNAME='DBLE'
            BADFUN=.TRUE.
        ELSE
            CALL OUTWRN('Already single-precision (REAL)')
        END IF
        RETURN
 
C FLOAT
10000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                FNAME='DBLE'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38 .OR. NTYPE.EQ.30) THEN
                CALL OUTINF('Probably unnecessary FLOAT declaration')
            ELSE
                CALL OUTERR('Cannot transform FLOAT usage')
            END IF
        ELSE
            CALL OUTWRN('Already single-precision (FLOAT)')
        END IF
        RETURN
 
C IFIX
11000   CONTINUE
        IF (RTODBL) THEN
            IF (NTYPE.EQ.119) THEN
                FNAME='INT'
                BADFUN=.TRUE.
            ELSE IF (NTYPE.EQ.38) THEN
                IF (ZYNEXT(PTR).NE.0) THEN
                    PTR=ZYPREV(PTR)
                    CALL ZYDELT(ZYNEXT(PTR))
                ELSE
                    CALL OUTINF('Unnecessary IFIX declaration')
                END IF
            ELSE
                FNAME='IDINT'
                BADFUN=.TRUE.
                CALL OUTERR('Invalid IFIX usage - changed to IDINT')
            END IF
        ELSE
            CALL OUTWRN('Already single-precision (IFIX)')
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       C H C N A M   -   Change COMMON block name (NAG routines only)
C
 
        SUBROUTINE CHCNAM(NODE)
        INTEGER NODE
 
        COMMON/OPTS/CVTNAM,RTODBL,CVTAUX,CVTCOM,DTFORM
        LOGICAL CVTNAM,RTODBL,CVTAUX,CVTCOM
        INTEGER DTFORM
 
C CRP "%<[A-Z]><[A-Z][0-9][0-9]><[A-Z][A-Z]>$"
C CDP "%<[A-Z][A-Z]><[A-Z][0-9][0-9]><[A-Z]>$"
C CR "&3&2&1"
 
        INTEGER CRP(39),CDP(39),CR(7),STATUS,SYMBOL(8),
     +          TEXT1(134),TEXT2(134),STRPTR,SYMPTR
 
        INTEGER ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYASYM,ADDSTR
        EXTERNAL ZSETP,ZSETR,ZPREPL,ZYDOWN,ZYASYM,ADDSTR,ZYGTSY,ZMESS,
     +           ERROR
 
        SAVE CRP,CDP,CR,/OPTS/
 
        DATA CRP/37,60,91,65,45,90,93,62,
     +60,91,65,45,90,93,91,48,45,57,93,
     +91,48,45,57,93,62,60,91,65,45,90,
     +93,91,65,45,90,93,62,36,129/,
     +       CDP/37,60,91,65,45,90,93,91,65,
     +45,90,93,62,60,91,65,45,90,93,
     +91,48,45,57,93,91,48,45,57,93,
     +62,60,91,65,45,90,93,62,36,129/,
     +       CR/38,51,38,50,38,49,129/
 
        CALL ZYGTSY(-ZYDOWN(NODE),SYMBOL)
        IF (SYMBOL(1).NE.2) THEN
            CALL ZMESS('ISTPT: Common pointers invalid',2)
            CALL ERROR('Fatal Error - Invalid Input')
        END IF
        CALL ZYGTST(SYMBOL(2),TEXT1)
        IF (RTODBL) THEN
            STATUS=ZSETP(CRP,.TRUE.)
        ELSE
            STATUS=ZSETP(CDP,.TRUE.)
        END IF
        STATUS=ZSETR(CR)
        IF (ZPREPL(TEXT1,TEXT2,.FALSE.).EQ.-2) THEN
            STRPTR=ADDSTR(TEXT2)
            SYMPTR=ZYASYM(STRPTR,SYMBOL(3),SYMBOL(1))
            CALL ZYCHDN(NODE,-SYMPTR)
        END IF
 
        END
C ----------------------------------------------------------------------
C
C       O U T E R R   -   Output an error message to the tty & the prog
C
 
        SUBROUTINE OUTERR(ERRTXT)
        CHARACTER*(*) ERRTXT
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER ERRMSG(134)
 
        SAVE
 
        INTEGER LENGTH
        EXTERNAL ZCHOUT,ZFTOI,ZTOKWR,LENGTH,PUTCH,ZPTINT
 
        DATA (ERRMSG(I),I=1,12)/67,42,80,84,42,69,82,82,79,
     +82,42,32/
 
        CALL ZCHOUT('Error: ',2)
        CALL ZCHOUT(ERRTXT,2)
        IF (PUNAME.NE.' ') THEN
            CALL ZCHOUT(' at statement ',2)
            CALL ZPTINT(STMTNO,1,2)
            CALL ZCHOUT(' in '//PUNAME,2)
        END IF
        CALL PUTCH(10,2)
        CALL ZFTOI(ERRTXT,1,132,ERRMSG(13),.TRUE.)
        CALL ZTOKWR(TCMMNT,LENGTH(ERRMSG),ERRMSG,TKDESC)
        NERROR=NERROR+1
 
        END
C ----------------------------------------------------------------------
C
C       O U T W R N   -   Output a warning message to the tty & the prog
C
 
        SUBROUTINE OUTWRN(ERRTXT)
        CHARACTER*(*) ERRTXT
 
        COMMON/PTIO/ IODCMT,TKDESC
        INTEGER IODCMT,TKDESC
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
C---------------------------------------------------------
C    TOOLPACK/1    Release: 2.4
C---------------------------------------------------------
C
C  TKLAST = LAST TOKEN NUMBER
C
      INTEGER TZEOF ,TASSIG,TBACKS,TBLOCK,TCALL ,TCLOSE,TCOMMO,TCONTI,
     +        TDATA ,TDO   ,TDIMEN,TELSE ,TELSIF,TEND  ,TENDFI,TENDIF,
     +        TENTRY,TEQUIV,TEXTER,TFUNCT,TFORMA,TGOTO ,TIF   ,TIMPLI,
     +        TINQUI,TINTRI,TOPEN ,TPARAM,TPAUSE,TPRINT,TPROGR,TREAD ,
     +        TRETUR,TREWIN,TSAVE ,TSTOP ,TSUBRO,TTHEN ,TTO   ,TWRITE,
     +        TINTEG,TREAL ,TDOUBL,TCOMPL,TLOGIC,TCHARA,TDCMPL,TCOMMA,
     +        TEQUAL,TCOLON,TLPARN,TRPARN,TLE   ,TLT   ,TEQ   ,TNE   ,
     +        TGE   ,TGT   ,TAND  ,TOR   ,TEQV  ,TNEQV ,TNOT  ,TSTAR ,
     +        TDSTAR,TPLUS ,TMINUS,TSLASH,TCNCAT,TDCNST,TLCNST,TRCNST,
     +        TPCNST,TCCNST,THCNST,TNAME ,TFIELD,TSCALE,TZEOS ,TCMMNT,
     +        TFMTKD,TENDKD,TERRKD,TKLAST
      PARAMETER (TZEOF = 1,TASSIG= 2,TBACKS= 3,TBLOCK= 4,TCALL = 5,
     +           TCLOSE= 6,TCOMMO= 7,TCONTI= 8,TDATA = 9,TDO   =10,
     +           TDIMEN=11,TELSE =12,TELSIF=13,TEND  =14,TENDFI=15,
     +           TENDIF=16,TENTRY=17,TEQUIV=18,TEXTER=19,TFUNCT=20,
     +           TFORMA=21,TGOTO =22,TIF   =23,TIMPLI=24,TINQUI=25,
     +           TINTRI=26,TOPEN =27,TPARAM=28,TPAUSE=29,TPRINT=30,
     +           TPROGR=31,TREAD =32,TRETUR=33,TREWIN=34,TSAVE =35,
     +           TSTOP =36,TSUBRO=37,TTHEN =38,TTO   =39,TWRITE=40,
     +           TINTEG=41,TREAL =42,TDOUBL=43,TCOMPL=44,TLOGIC=45,
     +           TCHARA=46,TDCMPL=47,TCOMMA=48,TEQUAL=49,TCOLON=50,
     +           TLPARN=51,TRPARN=52,TLE   =53,TLT   =54,TEQ   =55,
     +           TNE   =56,TGE   =57,TGT   =58,TAND  =59,TOR   =60,
     +           TEQV  =61,TNEQV =62,TNOT  =63,TSTAR =64,TDSTAR=65,
     +           TPLUS =66,TMINUS=67,TSLASH=68,TCNCAT=69,TDCNST=70,
     +           TLCNST=71,TRCNST=72,TPCNST=73,TCCNST=74,THCNST=75,
     +           TNAME =76,TFIELD=77,TSCALE=78,TZEOS =79,TCMMNT=80,
     +           TFMTKD=81,TENDKD=82,TERRKD=83,TKLAST=83)
 
 
        INTEGER ERRMSG(134)
 
        SAVE
 
        INTEGER LENGTH
        EXTERNAL ZCHOUT,ZMESS,ZFTOI,ZTOKWR,LENGTH
 
        DATA (ERRMSG(I),I=1,14)/67,42,80,84,42,87,65,82,78,
     +73,78,71,42,32/
 
        CALL ZCHOUT('Warning: ',2)
        CALL ZCHOUT(ERRTXT,2)
        IF (PUNAME.NE.' ') THEN
            CALL ZCHOUT(' at statement ',2)
            CALL ZPTINT(STMTNO,1,2)
            CALL ZCHOUT(' in '//PUNAME,2)
        END IF
        CALL PUTCH(10,2)
        CALL ZFTOI(ERRTXT,1,132,ERRMSG(15),.TRUE.)
        CALL ZTOKWR(TCMMNT,LENGTH(ERRMSG),ERRMSG,TKDESC)
        NWARN=NWARN+1
 
        END
C ----------------------------------------------------------------------
C
C       O U T I N F   -   Output an informational message
C
 
        SUBROUTINE OUTINF(ERRTXT)
        CHARACTER*(*) ERRTXT
 
        COMMON/PTERRC/NERROR,NWARN,PUNUM,STMTNO
        INTEGER NERROR,NWARN,PUNUM,STMTNO
 
        COMMON/PUNAMC/PUNAME
        CHARACTER*6 PUNAME
 
        SAVE
 
        EXTERNAL ZCHOUT,PUTCH,ZPTINT
 
        CALL ZCHOUT('Info: ',2)
        CALL ZCHOUT(ERRTXT,2)
        IF (PUNAME.NE.' ') THEN
            CALL ZCHOUT(' at statement ',2)
            CALL ZPTINT(STMTNO,1,2)
            CALL ZCHOUT(' in '//PUNAME,2)
        END IF
        CALL PUTCH(10,2)
 
        END
